home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / prolog / modprolg / mod-prol.lha / Prolog / modlib / src / $read.P < prev    next >
Encoding:
Text File  |  1992-05-20  |  31.6 KB  |  890 lines
  1. %   File   : READ.PL
  2. %   Author : D.H.D.Warren + Richard O'Keefe
  3. %   Modified for SB-Prolog by Saumya K. Debray & Deeporn Beardsley
  4. %   Updated: July 1988
  5. %   Purpose: Read Prolog terms in Dec-10 syntax.
  6. /*
  7.     Modified by Alan Mycroft to regularise the functor modes.
  8.     This is both easier to understand (there are no more '?'s),
  9.     and also fixes bugs concerning the curious interaction of cut with
  10.     the state of parameter instantiation.
  11.  
  12.     Since this file doesn't provide "metaread", it is considerably
  13.     simplified.  The token list format has been changed somewhat, see
  14.     the comments in the RDTOK file.
  15.  
  16.     I have added the rule X(...) -> apply(X,[...]) for Alan Mycroft.
  17. */
  18.  
  19. /****************************************************************************
  20.  *                                                                          *
  21.  * This file has been changed by to include Modules Extensions              *
  22.  * Changes by : Brian Paxton 1991/92                                        *
  23.  * Last update : June 1992                                                  *
  24.  *                                                                          *
  25.  * Organisation : University of Edinburgh.                                  *
  26.  * For : Departments of Computer Science and Artificial Intelligence        * 
  27.  *       Fourth Year Project.                                               *
  28.  *                                                                          *
  29.  ****************************************************************************/
  30.  
  31. $read_export([$read/1,$read/2,$read_module/1,$read/3]). 
  32.  
  33. % $read_use : $bmeta, $meta, $bio, $io, $blist, $retr, $name, $modules
  34.  
  35. %   $read(?Answer). 
  36.  
  37. $read(Answer) :- $read(Answer, _, perv). 
  38.  
  39. %   $read(?Answer, ?Arg)
  40. %   reads a term from the current input stream. Arg may be the list of 
  41. %   variables in the expression (a list of [Atom=Variable] pairs) or a 
  42. %   structure tag.
  43.  
  44. $read(Answer, Variables) :-
  45.     var(Variables), !,
  46.     $read(Answer, Variables, perv).
  47.  
  48. $read(Answer, Tag) :-
  49.     $isa_structuretag(Tag),
  50.     $read(Answer, _, Tag).
  51.  
  52. %   $read(?Answer, -Vars, ?Str)
  53. %   Read Answer from the standard input with respect to the structure Str,
  54. %   giving a list of variables Vars.
  55.  
  56. $read(Answer,Variables,Tag) :-
  57.     ( $isa_structuretag(Tag) -> 
  58.         ( repeat,
  59.           $read_tokens(Tokens, Variables),
  60.           ( Tag == perv -> Tokens1 = Tokens ;
  61.                            $dereference_input(Tokens, Tokens1, Tag) ),
  62.           ( ( $read(Tokens1, 1200, Term, Leftover, Tag),
  63.               $read_all(Leftover) ;
  64.               $read_syntax_error(Tokens1) ) ),
  65.           !,
  66.           Term = Answer ) ;
  67.         ( $writename('*** Error : Third argument to read/3 must be a structure tag'),
  68.           $nl, fail ) ).
  69.  
  70. %   $dereference_input(+Tokens, -New, +Tag)
  71. %
  72. % Once the tokens have been read in, this routine is called to pre-process
  73. % any colons (:) in the input into the correct dereferenced item. All
  74. % paths must be written in the infix : notation. After processing, the result
  75. % is a list of tokens like the original list, but any paths have been 
  76. % changed into an atom with the correct structure tag which can be passed
  77. % on to the original read processing routines.
  78.  
  79. $dereference_input([], [], _).
  80. $dereference_input([atom(Atom), atom(':')|Tail],[atom(Newatom)|Newtail],Tag) :-
  81.     $get_path([atom(Atom), atom(':')|Tail], Path, Function, Leftover), !,
  82.     $dereference_path(Path, Function, Newatom, Tag),
  83.     $dereference_input(Leftover, Newtail, Tag).
  84. $dereference_input([atom(':')|_], _, _) :- !,
  85.     $writename('** Error : Illegal use of : path constructor'),
  86.     $nl, fail.
  87. $dereference_input([Head|Tail], [Head|Newtail], Tag) :- !,
  88.     $dereference_input(Tail, Newtail, Tag).
  89.  
  90. $get_path([atom(Atom1), atom(':'), atom(Atom2), atom(':')|Tail],
  91.       Atom1:Path, Function, Leftover) :-
  92.     $get_path([atom(Atom2), atom(':')|Tail], Path, Function, Leftover).
  93. $get_path([atom(Atom1), atom(':'), atom(Atom2)|Tail], Atom1, Atom2, Tail).
  94.  
  95. $dereference_path(Path, Item, Newitem, Strtag) :-
  96.         $module_structure(_,Strtag,Substrs,_,_),
  97.     $memberchk(Path ---> Tag, Substrs) ->
  98.         $dismantle_name(Newitem, Item, Tag) ;
  99.         ( $writename('*** Error: Unknown structure '),
  100.               $write(Path),
  101.           $writename(' during read'),
  102.               $nl, fail ).
  103.  
  104.  
  105. %   $read_all(+Tokens)
  106. % 
  107. $read_all([]) :- !. 
  108. $read_all(S) :-
  109.         $read_syntax_error(['operator expected after expression'], S). 
  110.  
  111.  
  112. %   $read_expect(Token, TokensIn, TokensOut)
  113. %   reads the next token, checking that it is the one expected, and
  114. %   giving an error message if it is not.  It is used to look for
  115. %   right brackets of various sorts, as they're all we can be sure of. 
  116.  
  117. $read_expect(Token, [Token|Rest], Rest) :- !. 
  118. $read_expect(Token, S0, _) :-
  119.         $read_syntax_error([Token,'or operator expected'], S0). 
  120.  
  121.  
  122. %   I want to experiment with having the operator information held as
  123. %   ordinary Prolog facts.  For the moment the following predicates
  124. %   remain as interfaces to curr_op. 
  125. %   $read_prefixop(O -> Self, Rarg)
  126. %   $read_postfixop(O -> Larg, Self)
  127. %   $read_infixop(O -> Larg, Self, Rarg)
  128.  
  129. % Note that to perform this next predicate in the modules environment, we
  130. % need to pass in the current structure tag and return the name of the
  131. % operator (which is not necessarily the one passed in - it may now
  132. % have a tag).
  133.  
  134.  
  135. $check_mapped(F1,Arity,F2,Tag) :-
  136.     $symtype($mapped_function(_,_,_,_), Type),
  137.     ( ( Type > 0, $mapped_function(F1,Arity,F2,_) ) ;  % &&
  138.       F2 = F1 ),!.
  139.  
  140. % Purpose of line ** and similar ones :
  141. % If the operator under consideration has not yet been tagged it is either,
  142. % a pervasive operator of the desired type or a operator from the current
  143. % structure of the required type (or neither). This code first tries the
  144. % current structure operator, then the pervasive one.
  145.  
  146. $read_prefixop(F0, F2, X, Y, Tag) :- 
  147.     ( ( $dismantle_name(F0, _, perv), $dismantle_name(F1, F0, Tag) ) ;  %**
  148.       F1 = F0 ),
  149.     $read_prefixop(F1, X, Y),
  150.     $check_mapped(F1,1,F2,Tag), !.
  151.  
  152. $read_prefixop(Op, Prec, Prec) :-
  153.         $read_curr_op(Prec, fy, Op), !. 
  154. $read_prefixop(Op, Prec, Less) :-
  155.         $read_curr_op(Prec, fx, Op), !,
  156.         Less is Prec-1. 
  157.  
  158. $read_postfixop(F0, F2, Prec, Prec1, Tag) :-
  159.     ( ( $dismantle_name(F0, _, perv), $dismantle_name(F1, F0, Tag) ) ;
  160.       F1 = F0 ),
  161.     $read_postfixop(F1, Prec, Prec1),
  162.     $check_mapped(F1,1,F2,Tag), !.
  163.  
  164. $read_postfixop(Op, Prec, Prec) :-
  165.         $read_curr_op(Prec, yf, Op), !. 
  166. $read_postfixop(Op, Less, Prec) :-
  167.         $read_curr_op(Prec, xf, Op), !, Less is Prec-1. 
  168.  
  169. $read_infixop(F0, F2, X, Y, Z, Tag) :-
  170.     ( ( $dismantle_name(F0, _, perv), $dismantle_name(F1, F0, Tag) ) ;
  171.       F1 = F0 ),
  172.     $read_infixop(F1, X, Y, Z),
  173.     $check_mapped(F1,2,F2,Tag), !.
  174.  
  175. $read_infixop(Op, Less, Prec, Less) :-
  176.         $read_curr_op(Prec, xfx, Op), !, Less is Prec-1. 
  177. $read_infixop(Op, Less, Prec, Prec) :-
  178.         $read_curr_op(Prec, xfy, Op), !, Less is Prec-1. 
  179. $read_infixop(Op, Prec, Prec, Less) :-
  180.         $read_curr_op(Prec, yfx, Op), !, Less is Prec-1. 
  181.  
  182.  
  183. $read_ambigop(F, F1, F2, L1, O1, R1, L2, O2, Tag) :-
  184.         $read_postfixop(F, F1, L2, O2, Tag),
  185.         $read_infixop(F, F2, L1, O1, R1, Tag), !. 
  186.  
  187.  
  188. %   $read(+TokenList, +Precedence, -Term, -LeftOver, +Tag)
  189. %   parses a Token List in a context of given Precedence,
  190. %   returning a Term and the unread Left Over tokens.
  191.  
  192. :- mode($read,5,[nv,nv,d,d,d]).
  193.  
  194.  
  195. $read([Token|RestTokens], Precedence, Term, LeftOver, Tag) :-
  196.         $read(Token, RestTokens, Precedence, Term, LeftOver, Tag).
  197. $read([], _, _, _, _) :-
  198.         $read_syntax_error(['expression expected'], []).
  199.  
  200.  
  201. %   $read(+Token, +RestTokens, +Precedence, -Term, -LeftOver, +Tag)
  202. %   Renamed as well.
  203.  
  204. :- mode($read,6,[nv,nv,c,d,d,d]).
  205.  
  206. $read(var(Variable,_), ['('|S1], Precedence, Answer, S, Tag) :- !,
  207.         $read(S1, 999, Arg1, S2, Tag),
  208.         $read_args(S2, RestArgs, S3, Tag), !,
  209.         $read_exprtl0(S3,apply(Variable,[Arg1|RestArgs]),Precedence,Answer,S,
  210.                   Tag).
  211.  
  212. $read(var(Variable,_), S0, Precedence, Answer, S, Tag) :- !,
  213.         $read_exprtl0(S0, Variable, Precedence, Answer, S, Tag).
  214.  
  215. $read(atom(-), [number(Num)|S1], Precedence, Answer, S, Tag) :-
  216.         Negative is -Num, !,
  217.         $read_exprtl0(S1, Negative, Precedence, Answer, S, Tag).
  218.  
  219. $read(atom(Functor), ['('|S1], Precedence, Answer, S, Tag) :- !,
  220.         $read(S1, 999, Arg1, S2, Tag),
  221.         $read_args(S2, RestArgs, S3, Tag),
  222.     $length([Arg1|RestArgs],Arity),
  223.     ( $pervasive(Functor/Arity) -> 
  224.           Functor0 = Functor ;
  225.           ( $dismantle_name(Functor, _, Oldtag),
  226.             ( Oldtag == perv -> $dismantle_name(Functor0, Functor, Tag) ;
  227.                             Functor0 = Functor ) ) ),
  228.     $check_mapped(Functor0,Arity,Functor1,Tag),
  229.         $univ(Term,[Functor1,Arg1|RestArgs]), !,
  230.         $read_exprtl0(S3, Term, Precedence, Answer, S, Tag).
  231.  
  232. $read(atom(Functor), S0, Precedence, Answer, S, Tag) :-
  233.         $read_prefixop(Functor, Functor1, Prec, Right, Tag), !,
  234.         $read_aft_pref_op(Functor1, Functor, Prec, Right, S0, Precedence, 
  235.                       Answer, S, Tag).
  236.  
  237. $read(atom(Atom), S0, Precedence, Answer, S, Tag) :- !,
  238.     ( $pervasive0(Atom) -> 
  239.           Atom0 = Atom ;
  240.           ( $dismantle_name(Atom, _, Oldtag),
  241.             ( Oldtag == perv -> $dismantle_name(Atom0, Atom, Tag) ;
  242.                             Atom0 = Atom ) ) ),
  243.     $check_mapped(Atom0,0,Atom1,Tag),
  244.         $read_exprtl0(S0, Atom1, Precedence, Answer, S, Tag).
  245.  
  246. $read(number(Num), S0, Precedence, Answer, S, Tag) :- !,
  247.         $read_exprtl0(S0, Num, Precedence, Answer, S, Tag).
  248.  
  249. $read('[', [']'|S1], Precedence, Answer, S, Tag) :- !,
  250.         $read_exprtl0(S1, [], Precedence, Answer, S, Tag).
  251.  
  252. $read('[', S1, Precedence, Answer, S, Tag) :- !,
  253.         $read(S1, 999, Arg1, S2, Tag),
  254.         $read_list(S2, RestArgs, S3, Tag), !,
  255.         $read_exprtl0(S3, [Arg1|RestArgs], Precedence, Answer, S, Tag).
  256.  
  257. $read('(', S1, Precedence, Answer, S, Tag) :- !,
  258.         $read(S1, 1200, Term, S2, Tag),
  259.         $read_expect(')', S2, S3), !,
  260.         $read_exprtl0(S3, Term, Precedence, Answer, S, Tag).
  261.  
  262. $read(' (', S1, Precedence, Answer, S, Tag) :- !,
  263.         $read(S1, 1200, Term, S2, Tag),
  264.         $read_expect(')', S2, S3), !,
  265.         $read_exprtl0(S3, Term, Precedence, Answer, S, Tag).
  266.  
  267. $read('{', ['}'|S1], Precedence, Answer, S, Tag) :- !,
  268.         $read_exprtl0(S1, '{}', Precedence, Answer, S, Tag).
  269.  
  270. $read('{', S1, Precedence, Answer, S, Tag) :- !,
  271.         $read(S1, 1200, Term, S2, Tag),
  272.         $read_expect('}', S2, S3), !,
  273.         $read_exprtl0(S3, '{}'(Term), Precedence, Answer, S, Tag).
  274.  
  275. $read(string(List), S0, Precedence, Answer, S, Tag) :- !,
  276.         $read_exprtl0(S0, List, Precedence, Answer, S, Tag).
  277.  
  278. $read(Token, S0, _, _, _, _) :-
  279.         $read_syntax_error([Token,'cannot start an expression'], S0).
  280.  
  281.  
  282. %   $read_args(+Tokens, -TermList, -LeftOver, +Tag)
  283. %   parses {',' expr(999)} ')' and returns a list of terms.
  284.  
  285. $read_args([Tok|S1], Term, S, Tag) :-
  286.         '_$savecp'(CP),
  287.         $read_args1(Tok,Term,S,S1,CP, Tag), '_$cutto'(CP).
  288. $read_args(S, _, _, _) :-
  289.         $read_syntax_error([', or ) expected in arguments'], S).
  290.  
  291. :- mode($read_args1,6,[c,nv,d,d,d,d]).
  292.  
  293. $read_args1(',',[Term|Rest],S,S1,CP, Tag) :- 
  294.         $read(S1, 999, Term, S2, Tag), '_$cutto'(CP),
  295.         $read_args(S2, Rest, S, Tag).
  296. $read_args1(')',[],S,S,_,_).
  297.  
  298.  
  299.  
  300. %   $read_list(+Tokens, -TermList, -LeftOver, +Tag)
  301. %   parses {',' expr(999)} ['|' expr(999)] ']' and returns a list of terms.
  302.  
  303. $read_list([Tok|S1],Term,S, Tag) :-
  304.         '_$savecp'(CP),
  305.         $read_list1(Tok,Term,S,S1,CP, Tag),
  306.         '_$cutto'(CP).
  307. $read_list(S, _, _, _) :-
  308.         $read_syntax_error([', | or ] expected in list'], S).
  309.  
  310.  
  311. :- mode($read_list1,6,[c,nv,d,d,d,d]).
  312.  
  313. $read_list1(',',[Term|Rest],S,S1,CP, Tag) :-
  314.         $read(S1, 999, Term, S2, Tag), '_$cutto'(CP),
  315.         $read_list(S2, Rest, S, Tag).
  316. $read_list1('|',Rest,S,S1,CP, Tag) :-
  317.         $read(S1, 999, Rest, S2, Tag), '_$cutto'(CP),
  318.         $read_expect(']', S2, S).
  319. $read_list1(']',[],S,S,_,_).
  320.  
  321.  
  322. %   $read_aft_pref_op(+Op, +Oldop, +Prec, +ArgPrec, +Rest, +Precedence, -Ans, 
  323. %                     -LeftOver, +Tag)
  324. %
  325. % Since an operators internal name can be different from its typed name in
  326. % modular Prolog (because of a mapped function), we pass the typed name in
  327. % here just is case it turns out not to be an operator after all.
  328.  
  329. :- mode($read_aft_pref_op,9,[nv,nv,nv,nv,nv,nv,d,d,d]).
  330.  
  331. $read_aft_pref_op(Op, _, Oprec, Aprec, S0, Precedence, _, _, _) :-
  332.         Precedence < Oprec, !,
  333.         $read_syntax_error(['prefix operator',Op,'in context with precedence '
  334.                         ,Precedence], S0).
  335.  
  336. $read_aft_pref_op(Op, Oldop, Oprec, Aprec, S0, Precedence, Answer, S, Tag) :-
  337.         $read_peepop(S0, S1, Tag),
  338.         $read_prefix_is_atom(S1, Oprec), % can't cut but would like to
  339.     ( $pervasive0(Oldop) -> 
  340.           Oldop0 = Oldop ;
  341.           ( $dismantle_name(Oldop, _, Oldtag),
  342.             ( Oldtag == perv -> $dismantle_name(Oldop0, Oldop, Tag) ;
  343.                             Oldop0 = Oldop ) ) ),
  344.     $check_mapped(Oldop0,0,Oldop1,Tag),
  345.         $read_exprtl(S1, Oprec, Oldop1, Precedence, Answer, S, Tag).
  346.  
  347. $read_aft_pref_op(Op, _, Oprec, Aprec, S1, Precedence, Answer, S, Tag) :-
  348.         $read(S1, Aprec, Arg, S2, Tag),
  349.         $univ(Term,[Op,Arg]), !,
  350.         $read_exprtl(S2, Oprec, Term, Precedence, Answer, S, Tag).
  351.  
  352.  
  353. %   The next clause fixes a bug concerning "mop dop(1,2)" where
  354. %   mop is monadic and dop dyadic with higher Prolog priority.
  355.  
  356. $read_peepop([atom(F),'('|S1], [atom(F),'('|S1], Tag) :- !.
  357. $read_peepop([atom(F)|S1], [infixop(F0,L,P,R)|S1], Tag) :- 
  358.         $read_infixop(F, F0, L, P, R, Tag).
  359. $read_peepop([atom(F)|S1], [postfixop(F0,L,P)|S1], Tag) :- 
  360.         $read_postfixop(F, F0, L, P, Tag).
  361. $read_peepop(S0, S0, _).
  362.  
  363.  
  364. %   $read_prefix_is_atom(+TokenList, +Precedence)
  365. %   is true when the right context TokenList of a prefix operator
  366. %   of result precedence Precedence forces it to be treated as an
  367. %   atom, e.g. (- = X), p(-), [+], and so on.
  368.  
  369. $read_prefix_is_atom([Token|_], Precedence) :-
  370.         $read_prefix_is_atom(Token, Precedence).
  371.  
  372. $read_prefix_is_atom(infixop(_,L,_,_), P) :- L >= P.
  373. $read_prefix_is_atom(postfixop(_,L,_), P) :- L >= P.
  374. $read_prefix_is_atom(')', _).
  375. $read_prefix_is_atom(']', _).
  376. $read_prefix_is_atom('}', _).
  377. $read_prefix_is_atom('|', P) :- 1100 >= P.
  378. $read_prefix_is_atom(',', P) :- 1000 >= P.
  379. $read_prefix_is_atom([],  _).
  380.  
  381.  
  382. %   $read_exprtl0(+Tokens, +Term, +Prec, -Answer, -LeftOver, +Tag)
  383. %   is called by read/4 after it has read a primary (the Term).
  384. %   It checks for following postfix or infix operators.
  385.  
  386.  
  387. $read_exprtl0([atom(F)|S1], Term, Precedence, Answer, S, Tag) :-
  388.     $read_ambigop(F, F1, F2, L1, O1, R1, L2, O2, Tag), !,
  389.     (   $read_exprtl([infixop(F2,L1,O1,R1)|S1],0,Term,Precedence,Answer,S,
  390.                      Tag)
  391.     ;   $read_exprtl([postfixop(F1,L2,O2) |S1],0,Term,Precedence,Answer,S,
  392.                      Tag)
  393.     ).
  394. $read_exprtl0([atom(F)|S1], Term, Precedence, Answer, S, Tag) :-
  395.     $read_infixop(F, F0, L1, O1, R1, Tag), !,
  396.     $read_exprtl([infixop(F0,L1,O1,R1)|S1],0,Term,Precedence,Answer,S,Tag).
  397. $read_exprtl0([atom(F)|S1], Term, Precedence, Answer, S, Tag) :-
  398.     $read_postfixop(F, F0, L2, O2, Tag), !,
  399.     $read_exprtl([postfixop(F0,L2,O2)|S1],0,Term,Precedence,Answer,S,Tag).
  400. $read_exprtl0([','|S1], Term, Precedence, Answer, S, Tag) :-
  401.     Precedence >= 1000, !,
  402.     $read(S1, 1000, Next, S2, Tag), !,
  403.     $read_exprtl(S2, 1000, (Term,Next), Precedence, Answer, S, Tag).
  404. $read_exprtl0(['|'|S1], Term, Precedence, Answer, S, Tag) :-
  405.     Precedence >= 1100, !,
  406.     $read(S1, 1100, Next, S2, Tag), !,
  407.     $read_exprtl(S2, 1100, (Term;Next), Precedence, Answer, S, Tag).
  408. $read_exprtl0([Thing|S1], _, _, _, _, _) :-
  409.     $read_cfexpr(Thing, Culprit), !,
  410.     $read_syntax_error([Culprit,follows,expression], [Thing|S1]).
  411. $read_exprtl0(S, Term, _, Term, S, _).
  412.  
  413. :- mode($read_cfexpr,2,[nv,d]).
  414.  
  415. $read_cfexpr(atom(_),       atom).
  416. $read_cfexpr(var(_,_),      variable).
  417. $read_cfexpr(number(_),     number).
  418. $read_cfexpr(string(_),     string).
  419. $read_cfexpr(' (',          bracket).
  420. $read_cfexpr('(',           bracket).
  421. $read_cfexpr('[',           bracket).
  422. $read_cfexpr('{',           bracket).
  423.  
  424.  
  425. :- mode($read_exprtl,7,[nv,d,d,c,d,d,d]).
  426.  
  427. $read_exprtl([infixop(F,L,O,R)|S1], C, Term, Precedence, Answer, S, Tag) :-
  428.     Precedence >= O, C =< L, !,
  429.     $read(S1, R, Other, S2, Tag),
  430.     $univ(Expr,[F,Term,Other]), /*!,*/
  431.     $read_exprtl(S2, O, Expr, Precedence, Answer, S, Tag).
  432. $read_exprtl([postfixop(F,L,O)|S1], C, Term, Precedence, Answer, S, Tag) :-
  433.     Precedence >= O, C =< L, !,
  434.     $univ(Expr,[F,Term]),
  435.     $read_peepop(S1, S2, Tag),
  436.     $read_exprtl(S2, O, Expr, Precedence, Answer, S, Tag).
  437. $read_exprtl([','|S1], C, Term, Precedence, Answer, S, Tag) :-
  438.     Precedence >= 1000, C < 1000, !,
  439.     $read(S1, 1000, Next, S2, Tag), /*!,*/
  440.     $read_exprtl(S2, 1000, (Term,Next), Precedence, Answer, S, Tag).
  441. $read_exprtl(['|'|S1], C, Term, Precedence, Answer, S, Tag) :-
  442.     Precedence >= 1100, C < 1100, !,
  443.     $read(S1, 1100, Next, S2, Tag), /*!,*/
  444.     $read_exprtl(S2, 1100, (Term;Next), Precedence, Answer, S, Tag).
  445. $read_exprtl(S, _, Term, _, Term, S, _).
  446.  
  447.  
  448. %   This business of syntax errors is tricky.  When an error is detected,
  449. %   we have to write out a message.  We also have to note how far it was
  450. %   to the end of the input, and for this we are obliged to use the data-
  451. %   base.  Then we fail all the way back to $read(), and that prints
  452. %   the input list with a marker where the error was noticed.  If subgoal_of
  453. %   were available in compiled code we could use that to find the input
  454. %   list without hacking the data base.  The really hairy thing is that
  455. %   the original code noted a possible error and backtracked on, so that
  456. %   what looked at first sight like an error sometimes turned out to be
  457. %   a wrong decision by the parser.  This version of the parser makes
  458. %   fewer wrong decisions, and $ goal was to get it to do no backtracking
  459. %   at all.  This goal has not yet been met, and it will still occasionally
  460. %   report an error message and then decide that it is happy with the input
  461. %   after all.  Sorry about that.
  462.  
  463. /*  Modified by Saumya Debray, Nov 18 1986, to use SB-Prolog's database
  464.     facilities to print out error messages.                             */
  465.  
  466. $read_syntax_error(Message, List) :-
  467.         $length(List,Length),
  468.         $symtype('_$synerr'(_),X),
  469.         ( (X =:= 0 ; not('_$synerr'(_))) ->     /* _$synerr/1 undefined */
  470.                 $assert('_$synerr'(Length)) ;
  471.                 true
  472.         ),
  473.         !,
  474.         fail.
  475.  
  476. $read_syntax_error(List) :-
  477.         $nl, $print('*** syntax error ***'), $nl,
  478.         '_$synerr'(AfterError),
  479.         $retract('_$synerr'(AfterError)),
  480.         $length(List,Length),
  481.         BeforeError is Length - AfterError,
  482.         $read_display_list(List,BeforeError), !,
  483.         fail.
  484.  
  485. $read_display_list(X, 0) :-
  486.         $print('<<here>> '), !,
  487.         $read_display_list(X, 99999).
  488. $read_display_list([Head|Tail], BeforeError) :-
  489.         $print_token(Head),
  490.         $writename(' '),
  491.         Left is BeforeError-1, !,
  492.         $read_display_list(Tail, Left).
  493. $read_display_list([], _) :-
  494.         $nl.
  495.  
  496.  
  497. $print_list([]) :- $nl.
  498. $print_list([Head|Tail]) :-
  499.         $tab(1),
  500.         $print_token(Head),
  501.         $print_list(Tail).
  502.  
  503. $print_token(atom(X))    :- !, $print(X).
  504. $print_token(var(V,X))   :- !, $print(X).
  505. $print_token(number(X)) :-  !, $print(X).
  506. $print_token(string(X))  :- !, $print(X).
  507. $print_token(X)          :-    $print(X).
  508.  
  509.  
  510. /*
  511. %   $read_tokens(TokenList, Dictionary)
  512. %   returns a list of tokens.  It is needed to "prime" read_tokens/2
  513. %   with the initial blank, and to check for end of file.  The
  514. %   Dictionary is a list of AtomName=Variable pairs in no particular order.
  515. %   The way end of file is handled is that everything else FAILS when it
  516. %   hits character "-1", sometimes printing a warning.  It might have been
  517. %   an idea to return the atom 'end_of_file' instead of the same token list
  518. %   that you'd have got from reading "end_of_file. ", but (1) this file is
  519. %   for compatibility, and (b) there are good practical reasons for wanting
  520. %   this behaviour. */
  521.  
  522. $read_tokens(TokenList, Dictionary) :-
  523.         $read_next_token(Type,Value),
  524.     $read_insert_token(Type,Value,Dict,ListOfTokens),
  525.         $append(Dict, [], Dict), !, /*  fill in the "hole" at the end */
  526.         Dictionary = Dict,              /*  unify explicitly so we read and */
  527.         TokenList = ListOfTokens.       /*  then check even with filled in */
  528.                                         /*  arguments */
  529. $read_tokens([atom(end_of_file)], []).   /*  only thing that can go wrong */
  530.  
  531. $read_next_token(Type, Value) :- '_$builtin'(135).
  532.  
  533. $read_insert_token(X,Val,Dict,Tokens):-            
  534.   (X=:=0 ->
  535.       /**0**/                           /* punctuation */
  536.       (Tokens = [Val | TokRest],
  537.        $read_next_token(Type,Value),
  538.        $read_insert_token(Type,Value,Dict,TokRest)
  539.       );
  540.       (X<3 ->
  541.      (X=:=1 ->                      /* var */
  542.         /**1**/
  543.         (Val = Name, Tokens = [var(Var,Name) | TokRest], 
  544.          $read_lookup(Dict, Name=Var),
  545.          $read_next_token(Type,Value), 
  546.          $read_insert_token(Type,Value,Dict,TokRest)
  547.         );
  548.         /**2**/                    /* atom( */
  549.         (Tokens = [atom(Val) | ['(' | TokRest]],
  550.              $read_next_token(Type,Value),
  551.          $read_insert_token(Type,Value,Dict,TokRest)
  552.         )
  553.      );
  554.      (X<5 ->
  555.         (X=:=3 ->
  556.            /**3**/                /* number */
  557.            (Tokens = [number(Val) | TokRest],
  558.             $read_next_token(Type,Value),
  559.             $read_insert_token(Type,Value,Dict,TokRest)
  560.            ) ;
  561.            /**4**/                /* atom */
  562.            (Tokens = [atom(Val) | TokRest],
  563.             $read_next_token(Type,Value),
  564.          $read_insert_token(Type,Value,Dict,TokRest)
  565.            )
  566.         );
  567.         (X<7 ->
  568.            (X=:=5 ->
  569.            /**5**/                /* end of clause */
  570.            Tokens = [] ;
  571.            /**6**/            /* uscore */
  572.            (Tokens = [var(_,Val) | TokRest],
  573.             $read_next_token(Type,Value),
  574.                 $read_insert_token(Type,Value,Dict,TokRest)
  575.            )
  576.            ) ;
  577.            (X=:=7 ->
  578.            /**7**/            /* semicolon */
  579.            (Tokens = [atom((';')) | TokRest],
  580.             $read_next_token(Type,Value),
  581.                 $read_insert_token(Type,Value,Dict,TokRest)
  582.            );
  583.                  (X=:=8 ->
  584.                /**8**/            /* end of file */
  585.                fail ;
  586.                /**9**/            /* string */
  587.                (Tokens = [string(Val) | TokRest],
  588.                 $read_next_token(Type,Value),
  589.             $read_insert_token(Type,Value,Dict,TokRest)
  590.                )
  591.            )
  592.            )
  593.         )
  594.          )
  595.       )
  596.   ).
  597.  
  598.  
  599. %   read_lookup is identical to memberchk except for argument order and
  600. %   mode declaration.
  601.  
  602. $read_lookup([X|_], X) :- !.
  603. $read_lookup([_|T], X) :- $read_lookup(T, X).
  604.  
  605. /*
  606.   The rest of this file is concerned with reading in entire module
  607.   constructs into one term.
  608.   eg.   structure test/sig1 = struct
  609.                                  fun fun1/0.
  610.                                  test(fun1).
  611.                               end.
  612.       is returned as the term
  613.             structure('='('/'(test,sig1),[fun('/'(fun1,0)),test(fun1)]))
  614.       which is the same as
  615.             structure test/sig1 = [fun fun1/0,test(fun1)]
  616. */
  617.  
  618. % $read_module/1
  619. %
  620. % Read in an entire module construct.
  621.  
  622. $read_module(Answer) :-
  623.         repeat,
  624.         $read_tokens(Tokens, _),
  625.         $process_tokens(Tokens, Term), !,
  626.         Answer = Term.
  627.  
  628. % $process_tokens/2
  629. %
  630. % Check for signature, structure or functor declarations, if none, then
  631. % process as if it is a standard term.
  632.  
  633. $process_tokens([atom(signature)|Tail], Term) :- !,
  634.         $get_signature(Tail, Term).
  635.  
  636. $process_tokens([atom(structure)|Tail], Str) :- !,
  637.         $get_structure_head(Tail, Head, Leftover),
  638.         ( $get_strexpr(Leftover, Body, Sig, []) ->
  639.                ( Sig == $dummy -> Str = (structure Head = Body) ;
  640.                                   Str = (structure Head = Body/Sig) ) ;
  641.                ( $writename('** Read Error : Bad structure declaration for '),
  642.                  $write(Head), $nl, fail ) ).
  643.  
  644. $process_tokens([atom(functor)|Tail], Fun) :- !,
  645.         $get_functor_head(Tail, Head, Leftover),
  646.         ( $get_strexpr(Leftover, Body, Sig, []) ->
  647.                ( Sig == $dummy -> Fun = (functor Head = Body) ;
  648.                                   Fun = (functor Head = Body/Sig) ) ;
  649.                ( $writename('** Read Error : Bad functor declaration for '),
  650.                  $write(Head), $nl, fail ) ).
  651.  
  652. $process_tokens(Tokens, Term) :-
  653.         $read(Tokens, 1200, Term, Leftover, perv),
  654.         $read_all(Leftover).
  655.  
  656. $process_tokens(Tokens, _) :-
  657.         $read_syntax_error(Tokens).
  658.  
  659. % $get_signature/2
  660. %
  661. % Read in the head of a signature declaration.
  662.  
  663. $get_signature([atom(Atid), atom('='), atom(Atid2)], 
  664.                (signature Atid = Atid2) ) :- !.
  665. % ie.  signature X = Y.
  666.  
  667. $get_signature([atom(Atid), atom('='), atom(sig)|Spec],
  668.                (signature Atid = Speclist) ) :- !,
  669.         $get_speclist(Spec, Speclist, []).
  670. % ie.  signature X = sig ... end.
  671.  
  672. $get_signature([atom(Atid)|_], _) :- !,
  673.         $writename('** Read Error : Bad signature declaration for '),
  674.         $writename(Atid), $nl, fail.
  675.  
  676. $get_signature(_, _) :- !,
  677.         $writename('** Read Error : Bad signature declaration'), $nl, fail.
  678.  
  679. % $get_speclist/3
  680. %
  681. % Read the signature body into a list.
  682.  
  683. $get_speclist([atom(end_of_file)|_], _, _) :- !,
  684.         $writename('** Read Error : Unexpected end-of-file in signature body'),
  685.     $nl, fail.
  686.  
  687. $get_speclist([atom(end)|Rest], [], Leftover) :- !,
  688.         Rest = Leftover.
  689.  
  690. $get_speclist([atom(structure)|Tail], [structure(Term)|List], Left) :- !,
  691.     $get_structure_spec(Tail, Term) ->
  692.          $get_speclist(List, Left) ;
  693.          ( $writename('** Read Error : Bad structure spec in signature body'),
  694.            $nl, fail ).
  695.  
  696. $get_speclist(Tokens0, [Term|List], Left) :-
  697.         $read_on_failure(Tokens0, Tokens),
  698.         $read(Tokens, 1200, Term, Leftover, perv),
  699.          % Note we use the standard read routines here. There cannot be
  700.              % nested module constructs within a signature.
  701.         $read_all(Leftover), !,
  702.         $get_speclist(List, Left).
  703.  
  704. $get_speclist(List, Left) :-
  705.         $read_tokens(Tokens, _),
  706.         $get_speclist(Tokens, List, Left).
  707.  
  708. % $get_structure_spec/2
  709. %
  710. % Get the 'structure specstrb and ... and specstrb' part of the input.
  711.  
  712. $get_structure_spec([atom(Str), atom('/'), atom(Sig)|Rest], Term) :-
  713.     ( Sig = sig -> $get_speclist(Rest, Sig1, Rest1) ;
  714.                    ( Sig1 = Sig, Rest1 = Rest ) ),
  715.     ( Rest1 = [] -> Term = Str/Sig1 ;
  716.                    ( Rest1 = [atom(and)|Tail],
  717.                  $get_structure_spec(Tail, Term2),
  718.              Term = and(Str/Sig1, Term2) ) ).
  719.  
  720. % $read_on_failure/2
  721. %
  722.  
  723. $read_on_failure(Dec, Dec).
  724. $read_on_failure(_, Tokens) :-
  725.         $read_tokens(Readin, _),
  726.         $read_on_failure(Readin, Tokens).
  727.  
  728. % $get_structure_head/3
  729. %
  730. % Accept the head of a structure declaration.
  731.  
  732. $get_structure_head([atom(Atid), atom('/'), atom(sig)|Rest],
  733.                     Atid/Spec, Leftover) :- !,
  734.         $get_speclist(Rest, Spec, [atom('=')|Leftover]).
  735. % ie.  structure X/sig ... end = ... .
  736.  
  737. $get_structure_head([atom(Atid), atom('/'), atom(Sig), atom('=')|Rest],
  738.                     Atid/Sig, Rest) :- !.
  739. % ie.  structure X/Y = ... .
  740.  
  741. $get_structure_head([atom(Atid), atom('=')|Rest], Atid, Rest) :- !.
  742. % ie.  structure X = ... .
  743.  
  744. $get_structure_head([atom(Atid)|_], _, _) :- !,
  745.         $writename('** Read Error : Bad header in structure declaration for '),
  746.         $writename(Atid), $nl, fail.
  747.  
  748. $get_structure_head(_, _, _) :-
  749.         $writename('** Read Error : Bad header in structure declaration'),
  750.     $nl, fail.
  751.  
  752. % $get_functor_head/3
  753. %
  754. % Accept the head of a functor declaration.
  755.  
  756. $get_functor_head([atom(Atid), '('|Rest], Head, Left) :-
  757.         $get_functor_args(Rest, Args, Leftover),
  758.         ( Leftover = [atom('/'), atom(sig)|Tail] ->
  759.                 $get_speclist(Tail, Spec, [atom('=')|Left]) ;
  760.                 ( Leftover = [atom('/'), atom(Spec), atom('=')|Left] ->
  761.                         true ;
  762.                         ( Spec = $dummy,
  763.                           Leftover = [atom('=')|Left]) ) ),
  764.         $univ(Head0, [Atid|Args]),
  765.         ( Spec = $dummy -> Head = Head0 ;
  766.                            Head = Head0/Spec ), !.
  767.  
  768. $get_functor_head([atom(Atid)|_], _, _) :- !,
  769.         $writename('** Read Error : Bad header in functor declaration for '),
  770.         $writename(Atid), $nl, fail.
  771.  
  772. $get_functor_head(_, _, _) :- !,
  773.         $writename('** Read Error : Bad header in functor declaration'),
  774.     $nl, fail.
  775.  
  776. % $get_functor_args/3
  777. %
  778. % Read in the arguments to a functor. Note that these can themselves be
  779. % structures.
  780.  
  781. $get_functor_args([atom(Atid), atom('/'), atom(Sig)|Rest],
  782.                   [Result|Args], Left) :-
  783.         ( Sig == sig -> $get_speclist(Rest, Spec, Leftover) ;
  784.                         ( Sig = Spec,
  785.                           Leftover = Rest ) ),
  786.         ( Leftover = [')'|Left] -> 
  787.                 ( Args = [],
  788.           Result = Atid/Spec ) ;
  789.         ( Leftover = [atom('sharing')|More] ->
  790.             $get_functor_sharing(More, Atid, Spec, Left, Result) ;
  791.                     ( Leftover = [','|More],
  792.               Result = Atid/Spec, !,
  793.                       $get_functor_args(More, Args, Left) ) ) ), !.
  794.  
  795. $get_functor_args(_, _, _) :-
  796.         $writename('** Read Error : Bad functor arguments'), $nl, fail.
  797.  
  798. % $get_functor_sharing/4
  799. %
  800. % Read in the sharing portion of a functors argument list.
  801.  
  802. $get_functor_sharing(More, Atid, Spec, Leftover, sharing(Atid/Spec,Result)) :-
  803.     $append(Read, [')'|Leftover], More),
  804.     $read(Read, 1200, Result, [], perv).
  805.  
  806. $get_functor_sharing(_, _, _, _, _) :-
  807.     $writename('** Read Error : Bad sharing constraint in functor arguments'),
  808.         $nl, fail.
  809.  
  810. % $get_strexpr/4
  811. %
  812. % Read in a strexpr (the body of a structure).
  813.  
  814. $get_strexpr([atom(struct)|Rest], Body, Sig, Leftover) :- !,
  815.         $get_structure_body(Rest, Body, Sig, Leftover).
  816.  
  817. $get_strexpr([atom(Atid),'('|Rest], Body, Sig, Leftover0) :- !,
  818.         $get_strexpr_args(Rest, Args, Leftover),
  819.         $univ(Body, [Atid|Args]),
  820.         ( Leftover = [] -> 
  821.                 ( Sig = $dummy,
  822.                   Leftover0 = [] ) ;
  823.                 ( Leftover = [atom('/'), atom(sig)|Tokens] ->
  824.                         $get_speclist(Tokens, Sig, Leftover0) ;
  825.                         Leftover = [atom('/'), atom(Sig)|Leftover0]) ).
  826.  
  827. $get_strexpr(Tokens, Body, Sig, Leftover) :-
  828.     $get_strexpr_id(Tokens, Body, Left),
  829.     ( Left = [atom('/'),atom(sig)|Rest] ->
  830.           $get_speclist(Rest, Sig, Leftover) ;
  831.           ( Left = [atom('/'),atom(Sig)|Leftover] ->
  832.            true ;
  833.            ( Leftover = Left,
  834.              Sig = $dummy ) ) ).
  835.  
  836. % $get_strexpr_id/3
  837. %
  838.  
  839. $get_strexpr_id([atom(Id),atom(':'),atom(Id1),atom(':')|Rest],
  840.             Id:Path, Leftover) :- !,
  841.     $get_strexpr_id([atom(Id1),atom(':')|Rest], Path, Leftover).
  842. $get_strexpr_id([atom(Id),atom(':'),atom(Id1)|Rest], Id:Id1, Rest) :- !.
  843. $get_strexpr_id([atom(Id)|Rest], Id, Rest).
  844.  
  845. % $get_structure_body/4
  846. %
  847. % Read a structure body (within struct .. end delimiters) into a list.
  848.  
  849. $get_structure_body([atom(end), atom('/'), atom(sig)|Rest], [], Sig, 
  850.                     Leftover) :- !,
  851.         $get_speclist(Rest, Sig, Leftover).
  852. % Check for trailing signature.
  853.  
  854. $get_structure_body([atom(end), atom('/'), atom(Atid)|Leftover], [], Atid,
  855.                     Leftover) :- !.
  856. % Check for trailing signature.
  857.  
  858. $get_structure_body([atom(end)|Leftover], [], $dummy, Leftover) :- !.
  859.  
  860. $get_structure_body([atom(end_of_file)|_], _, _, _) :- !,
  861.         $writename('** Read Error : Unexpected end-of-file in structure body'),
  862.     $nl, fail.
  863.  
  864. $get_structure_body(Tokens0, [Term|List], Sig, Leftover) :-
  865.         $read_on_failure(Tokens0, Tokens),
  866.         $process_tokens(Tokens, Term), !,
  867.              % Recursive call here as structure can contain nested structures.
  868.         $get_structure_body(List, Sig, Leftover).
  869.  
  870. $get_structure_body(List, Sig, Leftover) :-
  871.         $read_tokens(Tokens, _),
  872.         $get_structure_body(Tokens, List, Sig, Leftover).
  873.  
  874. % $get_structure_args/3
  875. %
  876. % Read arguments to a functor application.
  877.  
  878. $get_strexpr_args(Tokens, [Arg0|Args], Left) :-
  879.         $get_strexpr(Tokens, Arg, Sig, Leftover),
  880.         ( Sig = $dummy -> Arg0 = Arg ;
  881.                           Arg0 = Arg/Sig ),
  882.         ( Leftover = [')'|Left] -> 
  883.                 Args = [] ;
  884.                 ( Leftover = [','|More], !,
  885.                   $get_strexpr_args(More, Args, Left) ) ), !.
  886.  
  887. $get_strexpr_args(_, _, _, _) :-
  888.         $writename('** Read Error : Bad arguments in functor application expression'),
  889.         $nl, fail.
  890.